home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / ISSUE04 / PERFORM / DIROUTLN.PAS next >
Encoding:
Pascal/Delphi Source File  |  1995-06-08  |  10.5 KB  |  373 lines
  1. unit DirOutln;
  2. { Directory outline component }
  3.  
  4. interface
  5.  
  6. uses Classes, Forms, Controls, Outline, SysUtils, Graphics;
  7.  
  8. type
  9.   TTextCase = (tcLowerCase, tcUpperCase, tcAsIs);
  10.   TCaseFunction = function(const AString: string): string;
  11.  
  12.   TDirectoryOutline = class(TCustomOutline)
  13.   private
  14.     FDrive: Char;
  15.     FDirectory: TFileName;
  16.     FOnChange: TNotifyEvent;
  17.     FTextCase: TTextCase;
  18.     FCaseFunction: TCaseFunction;
  19.   protected
  20.     procedure SetDrive(NewDrive: Char);
  21.     procedure SetDirectory(const NewDirectory: TFileName);
  22.     procedure SetTextCase(NewTextCase: TTextCase);
  23.     procedure AssignCaseProc;
  24.     procedure BuildOneLevel(RootItem: Longint); virtual;
  25.     procedure BuildTree; virtual;
  26.     procedure BuildSubTree(RootItem: Longint); virtual;
  27.     procedure Change; virtual;
  28.     procedure Click; override;
  29.     procedure CreateWnd; override;
  30.     procedure Expand(Index: Longint); override;
  31.     procedure Loaded; override;
  32.     procedure WalkTree(const Dest: string);
  33.   public
  34.     constructor Create(AOwner: TComponent); override;
  35.     function ForceCase(const AString: string): string;
  36.     property Drive: Char  read FDrive write SetDrive;
  37.     property Directory: TFileName  read FDirectory write SetDirectory;
  38.   published
  39.     property Align;
  40.     property Lines stored False;
  41.     property Options default [ooStretchBitmaps, ooDrawFocusRect];
  42.     property Font;
  43.     property OutlineStyle;
  44.     property ParentShowHint;
  45.     property PicturePlus;
  46.     property PictureMinus;
  47.     property PictureOpen;
  48.     property PictureClosed;
  49.     property PictureLeaf;
  50.     property ShowHint;
  51.     property TabOrder;
  52.     property TabStop;
  53.     property TextCase: TTextCase  read FTextCase write SetTextCase default tcLowerCase;
  54.     property OnChange: TNotifyEvent  read FOnChange write FOnChange;
  55.     property OnCollapse;
  56.     property OnDragDrop;
  57.     property OnDragOver;
  58.     property OnEnter;
  59.     property OnExit;
  60.     property OnExpand;
  61.   end;
  62.  
  63. function SameLetter(Letter1, Letter2: Char): Boolean;
  64.  
  65. procedure Register;
  66.  
  67. implementation
  68. {$DEFINE PROFILE}
  69. {$DEFINE DRBOB}
  70.  
  71. {$IFDEF PROFILE}
  72. Uses Dialogs;
  73. function timeGetTime: LongInt; far; external 'MMSYSTEM' index 607;
  74. {$ENDIF}
  75.  
  76. const
  77.   InvalidIndex = -1;
  78.  
  79. procedure Register;
  80. begin
  81.   RegisterComponents('Samples', [TDirectoryOutline]);
  82. end;
  83.  
  84. constructor TDirectoryOutline.Create(AOwner: TComponent);
  85. begin
  86.   inherited Create(AOwner);
  87.   PictureLeaf := PictureClosed;
  88.   Options := Options - [ooDrawTreeRoot] + [ooStretchBitmaps];
  89.   TextCase := tcLowerCase;
  90.   AssignCaseProc;
  91. end;
  92.  
  93. procedure TDirectoryOutline.AssignCaseProc;
  94. begin
  95.   case TextCase of
  96.     tcLowerCase: FCaseFunction := AnsiLowerCase;
  97.     tcUpperCase: FCaseFunction := AnsiUpperCase;
  98.     else FCaseFunction := nil;
  99.   end;
  100. end;
  101.  
  102. type
  103.   PNodeInfo = ^TNodeInfo;
  104.   TNodeInfo = record
  105.     RootName: TFileName;
  106.     SearchRec: TSearchRec;
  107.     DosError: Integer;
  108.     RootNode: TOutlineNode;
  109.     TempChild, NewChild: Longint;
  110.   end;
  111.  
  112.  
  113. procedure TDirectoryOutline.BuildOneLevel(RootItem: Longint);
  114. var
  115.   NodeInfo: PNodeInfo;
  116. {$IFDEF PROFILE}
  117.   Time: LongInt;
  118.   Str: String;
  119. {$ENDIF}
  120.  
  121. {$IFDEF DRBOB}
  122.   function FindIndex(RootNode: TOutLineNode; SearchName: TFileName): LongInt;
  123.   { speed-up by Dr. Bob: use Binary Search! }
  124.   var FirstChild,LastChild,TempChild: LongInt;
  125.   begin
  126.     FirstChild := RootNode.GetFirstChild;
  127.     if (FirstChild = InvalidIndex) or
  128.        (SearchName <= Items[FirstChild].Text) then FindIndex := FirstChild
  129.     else
  130.     begin
  131.       LastChild := RootNode.GetLastChild;
  132.       if SearchName >= Items[LastChild].Text then FindIndex := InvalidIndex {!}
  133.       else
  134.       begin
  135.         repeat
  136.           TempChild := (FirstChild + LastChild) div 2; { binary search }
  137.           if TempChild = FirstChild then Inc(TempChild);
  138.           if SearchName > Items[TempChild].Text then FirstChild := TempChild
  139.                                                 else LastChild := TempChild
  140.         until FirstChild >= (LastChild-1);
  141.         FindIndex := LastChild
  142.       end
  143.     end
  144.   end {FindIndex};
  145. {$ENDIF}
  146.  
  147. begin
  148.   {$IFDEF PROFILE}
  149.   Time := timeGetTime;
  150.   {$ENDIF}
  151.   New(NodeInfo);
  152.   try
  153.     with NodeInfo^ do
  154.     begin
  155.       RootName := Items[RootItem].FullPath;
  156.       if RootName[Length(RootName)] <> '\' then
  157.         RootName := Concat(RootName, '\');
  158.       RootName := Concat(RootName, '*.*');
  159.       RootNode := Items[RootItem]; { Dr. Bob: moved out of the while loop }
  160.       DosError := FindFirst(RootName, faDirectory, SearchRec);
  161.       while DosError = 0 do
  162.       begin
  163.         if (SearchRec.Attr and faDirectory = faDirectory) and (SearchRec.Name[1] <> '.') then
  164.         begin
  165.           SearchRec.Name := ForceCase(SearchRec.Name);
  166.           if RootNode.HasItems then { if has children, must alphabetize }
  167.           begin
  168.             {$IFNDEF DRBOB}
  169.             { Dr. Bottle-neck: Lineair Search applied: }
  170.             TempChild := RootNode.GetFirstChild;
  171.             while (TempChild <> InvalidIndex) and (Items[TempChild].Text < SearchRec.Name) do
  172.               TempChild := RootNode.GetNextChild(TempChild);
  173.             {$ELSE}
  174.             TempChild := FindIndex(RootNode, SearchRec.Name); { Dr. Bob }
  175.             {$ENDIF}
  176.             if TempChild <> InvalidIndex then
  177.               NewChild := Insert(TempChild, SearchRec.Name)
  178.             else NewChild := Add(RootNode.GetLastChild, SearchRec.Name);
  179.           end
  180.           else NewChild := AddChild(RootItem, SearchRec.Name); { if first child, just add }
  181.         end;
  182.         DosError := FindNext(SearchRec);
  183.       end;
  184.     end;
  185.     Items[RootItem].Data := Pointer(1); { make non-nil so we know we've been here }
  186.   finally
  187.   {$IFDEF PROFILE}
  188.     Time := timeGetTime - Time;
  189.     FmtStr(Str,'%s Time: %d',[NodeInfo^.RootName,Time]);
  190.     MessageDlg(Str,mtInformation,[mbOK],0);
  191.   {$ENDIF}
  192.     Dispose(NodeInfo);
  193.   end;
  194. end;
  195.  
  196. procedure TDirectoryOutline.BuildTree;
  197. var
  198.   RootNode: Longint;
  199. begin
  200.   Clear;
  201.   RootNode := AddChild(0, ForceCase(Drive + ':'));
  202.   WalkTree(FDirectory);
  203.   Change;
  204. end;
  205.  
  206. procedure TDirectoryOutline.BuildSubTree(RootItem: Longint);
  207. var
  208.   TempRoot: Longint;
  209.   RootNode: TOutlineNode;
  210. begin
  211.   BuildOneLevel(RootItem);
  212.   RootNode := Items[RootItem];
  213.   TempRoot := RootNode.GetFirstChild;
  214.   while TempRoot <> InvalidIndex do
  215.   begin
  216.     BuildSubTree(TempRoot);
  217.     TempRoot := RootNode.GetNextChild(TempRoot);
  218.   end;
  219. end;
  220.  
  221. procedure TDirectoryOutline.Change;
  222. begin
  223.   if Assigned(FOnChange) then FOnChange(Self);
  224. end;
  225.  
  226. procedure TDirectoryOutline.Click;
  227. begin
  228.   inherited Click;
  229.   Directory := Items[SelectedItem].FullPath;
  230. end;
  231.  
  232. procedure TDirectoryOutline.CreateWnd;
  233. var
  234.   CurrentPath: TFileName;
  235. begin
  236.   inherited CreateWnd;
  237.   if FDrive = #0 then
  238.   begin
  239.     GetDir(0, CurrentPath);
  240.     FDrive := ForceCase(CurrentPath)[1];
  241.     FDirectory := ForceCase(CurrentPath);
  242.   end;
  243.   if not (csLoading in ComponentState) then BuildTree;
  244. end;
  245.  
  246. procedure TDirectoryOutline.Expand(Index: Longint);
  247. begin
  248.   if Items[Index].Data = nil then { if we've not previously expanded }
  249.     BuildOneLevel(Index);
  250.   inherited Expand(Index); { call the event handler }
  251. end;
  252.  
  253. function TDirectoryOutline.ForceCase(const AString: string): string;
  254. begin
  255.   if Assigned(FCaseFunction) then
  256.     Result := FCaseFunction(AString)
  257.   else Result := AString;
  258. end;
  259.  
  260. procedure TDirectoryOutline.Loaded;
  261. begin
  262.   inherited Loaded;
  263.   AssignCaseProc;
  264.   BuildTree;
  265. end;
  266.  
  267. procedure TDirectoryOutline.SetDirectory(const NewDirectory: TFileName);
  268. var
  269.   TempPath: TFileName;
  270. begin
  271.   if Length(NewDirectory) > 0 then  { ignore empty directory }
  272.   begin
  273.     TempPath := ForceCase(ExpandFileName(NewDirectory)); { expand to full path }
  274.     if (Length(TempPath) > 3) and (TempPath[Length(TempPath)] = '\') then
  275.       TempPath[0] := Char(Length(TempPath) - 1);  {remove trailing backslash}
  276.     if CompareStr(TempPath, FDirectory) <> 0 then { is it a dir change? }
  277.     begin
  278.       FDirectory := TempPath; { set new directory }
  279.       ChDir(FDirectory); { go there }
  280.       if TempPath[1] <> Drive then { check to see if we changed drives, too }
  281.         Drive := TempPath[1] { change drive/build list if needed }
  282.       else
  283.       begin
  284.         WalkTree(TempPath);
  285.         Change; { otherwise, we're done }
  286.       end;
  287.     end;
  288.   end;
  289. end;
  290.  
  291. procedure TDirectoryOutline.SetDrive(NewDrive: Char);
  292. begin
  293.   if UpCase(NewDrive) in ['A'..'Z'] then { disallow all but drive letters}
  294.   begin
  295.     if (FDrive = #0) or not SameLetter(NewDrive, FDrive) then { update if no current drive or change }
  296.     begin
  297.       FDrive := NewDrive;
  298.       ChDir(FDrive + ':');
  299.       GetDir(0, FDirectory); { always returns uppercase...yuck! }
  300.       FDirectory := ForceCase(FDirectory); { use correct case }
  301.       if not (csLoading in ComponentState) then BuildTree; { this ends up calling Change }
  302.     end;
  303.   end;
  304. end;
  305.  
  306. procedure TDirectoryOutline.SetTextCase(NewTextCase: TTextCase);
  307. var
  308.   CurrentPath: TFileName;
  309. begin
  310.   if NewTextCase <> FTextCase then
  311.   begin
  312.     FTextCase := NewTextCase;
  313.     AssignCaseProc;
  314.     if NewTextCase = tcAsIs then
  315.     begin
  316.       GetDir(0, CurrentPath);
  317.       FDrive := CurrentPath[1];
  318.       FDirectory := CurrentPath;
  319.     end;
  320.     if not (csLoading in ComponentState) then BuildTree;
  321.   end;
  322. end;
  323.  
  324. procedure TDirectoryOutline.WalkTree(const Dest: string);
  325. var
  326.   TempPath, NextDir: TFileName;
  327.   SlashPos: Integer;
  328.   TempItem: Longint;
  329.  
  330.   function GetChildNamed(const Name: string): Longint;
  331.   begin
  332.     Items[TempItem].Expanded := True;
  333.     Result := Items[TempItem].GetFirstChild;
  334.     while Result <> InvalidIndex do
  335.     begin
  336.       if Items[Result].Text = Name then Exit;
  337.       Result := Items[TempItem].GetNextChild(Result);
  338.     end;
  339.   end;
  340.  
  341. begin
  342.   TempItem := 1; { start at root }
  343.   TempPath := ForceCase(Dest);
  344.   if Pos(':', TempPath) > 0 then
  345.     TempPath := Copy(TempPath, Pos(':', TempPath) + 1, Length(TempPath));
  346.   if TempPath[1] = '\' then System.Delete(TempPath, 1, 1);
  347.   SlashPos := Pos('\', TempPath);
  348.   NextDir := TempPath;
  349.   while Length(TempPath) > 0 do
  350.   begin
  351.     SlashPos := Pos('\', TempPath);
  352.     if SlashPos > 0 then
  353.     begin
  354.       NextDir := Copy(TempPath, 1, SlashPos - 1);
  355.       TempPath := Copy(TempPath, SlashPos + 1, Length(TempPath));
  356.     end
  357.     else
  358.     begin
  359.       NextDir := TempPath;
  360.       TempPath := '';
  361.     end;
  362.     TempItem := GetChildNamed(NextDir);
  363.   end;
  364.   SelectedItem := TempItem;
  365. end;
  366.  
  367. function SameLetter(Letter1, Letter2: Char): Boolean;
  368. begin
  369.   Result := UpCase(Letter1) = UpCase(Letter2);
  370. end;
  371.  
  372. end.
  373.